home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
SHELLS
/
SZ2
/
GDESKTOP.IMP
< prev
next >
Wrap
Text File
|
1992-08-31
|
17KB
|
483 lines
{*******************************************************************
GDESKTOP.IMP
*******************************************************************}
{===================================================================
HISTORY
===================================================================}
{-------------------------------------------------------------------
SAVE
-------------------------------------------------------------------}
procedure SaveHistory ( VAR S : TStream ) ;
var
Size : word ;
begin
if S.Status <> stOk then EXIT ;
Size := HistoryUsed
- PtrRec ( HistoryBlock ).Ofs ;
S.Write ( Size , SizeOf ( Word ) ) ;
S.Write ( HistoryBlock^ , Size ) ;
end ;
{-------------------------------------------------------------------
LOAD
-------------------------------------------------------------------}
procedure LoadHistory ( VAR S : TStream ) ;
var
Size : word ;
begin
if S.Status <> stOk then EXIT ;
S.Read ( Size , SizeOf ( Word ) ) ;
S.Read ( HistoryBlock^ , Size ) ;
if S.Status = stOk then
HistoryUsed := PtrRec ( HistoryBlock ).Ofs
+ Size
else
ClearHistory ;
end ;
{===================================================================
PALETTE - saves all three (3) palettes. Note that we do NOT want to
save the actual "AppPalette", since we would lose auto-detect. This
could happen when using dual monitors, changing from color to B&W or
vice-versa, and (no doubt) there are other possibilities.
To force a palette, use command-line switches and call hdColor,
hdBlackWhite or hdMonochrome AFTER application starts.
===================================================================}
{-------------------------------------------------------------------
SAVE
-------------------------------------------------------------------}
procedure SavePalette ( VAR S : TStream ) ;
var
SaveAppPalette : integer ;
P : PString ;
begin
if S.Status <> stOk then EXIT ;
SaveAppPalette := AppPalette ;
for AppPalette := apColor to apMonochrome do
begin
P := NewStr ( Application^.GetPalette^ ) ;
S.WriteStr ( P ) ;
DisposeStr ( P ) ;
end ;
AppPalette := SaveAppPalette ;
end ;
{-------------------------------------------------------------------
LOAD
-------------------------------------------------------------------}
procedure LoadPalette ( VAR S : TStream ) ;
var
SaveAppPalette : integer ;
P : PString ;
begin
if S.Status <> stOk then EXIT ;
SaveAppPalette := AppPalette;
for AppPalette := apColor to apMonochrome do
begin
P := S.ReadStr ;
Application^.GetPalette^ := TPalette ( P^ ) ;
DisposeStr ( P ) ;
end ;
AppPalette := SaveAppPalette ;
if S.Status <> stOk then
hdResetColors ;
hdRefreshDisplay ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
DESKTOP - Must apply TEditor Load/Store patch!
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
STORE
===================================================================}
procedure DesktopWriteViews ( VAR S : TStream ) ;
{-------------------------------------------------------------------
IF VISIBLE
-------------------------------------------------------------------}
procedure WriteView ( P : PView ) ; FAR ;
begin
if P = Desktop^.Last then EXIT ;
if P^.GetState ( sfVisible ) then
S.Put ( P ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
if S.Status <> stOk then EXIT ;
Desktop^.ForEach ( @WriteView ) ;
S.Put ( NIL ) ;
end ;
{===================================================================
LOAD - One at a time; "ValidView" calls "OutOfMemory" if LowMemory
is TRUE.
NOTE: Default "OutOfMemory" does nothing - should be overridden.
===================================================================}
procedure DesktopReadViews ( VAR S : TStream ) ;
var
P : PView ;
begin
if S.Status <> stOk then EXIT ;
while TRUE do
begin
P := PView ( S.Get ) ;
Desktop^.InsertBefore ( Application^. ValidView ( P ) ,
Desktop^.Last ) ;
if P = NIL then EXIT ;
end ;
end ;
{===================================================================
SAVE
===================================================================}
procedure SaveDesktopTo ( FileName : PathStr ; Description : string ) ;
var
Strm : PStream ;
begin
if FileName = '' then EXIT ;
SaveEdUntitled ; { save, or }
CloseEdUntitled ; { dump empties }
SaveEdModified ; { keep changes }
Strm := New ( PDosStream ,
Init ( FileName ,
stCreate ) ) ;
Description := Description + #26 ;
Strm^.Write ( Description[1] , length ( Description ) ) ;
Strm^.Write ( VersionCode[0] , length ( VersionCode ) + 1 ) ;
SaveHistory ( Strm^ ) ;
SavePalette ( Strm^ ) ;
DesktopWriteViews ( Strm^ ) ;
if Strm^.Status <> stOk then
begin
FileErase ( FileName ) ;
MessageBox ( ^C'Could not create'#13
+ FileName ,
NIL ,
mfError + mfOkButton ) ;
end ;
Dispose ( Strm , Done ) ;
end ;
{===================================================================
LOAD
===================================================================}
procedure LoadDesktopFrom ( FileName : PathStr ) ;
var
Strm : PStream ;
VersionCodeTest : string ;
Ch : char ;
begin
if not FileExist ( FileName ) then EXIT ;
CloseAll ;
Strm := New ( PDosStream ,
Init ( FileName ,
stOpenRead ) ) ;
Ch := #0 ;
while ( Ch <> ^Z ) and ( Strm^.Status = stOK ) do
Strm^.Read ( Ch , 1 ) ;
Strm^.Read ( VersionCodeTest [0] , 1 ) ;
Strm^.Read ( VersionCodeTest [1] , length ( VersionCode ) ) ;
if VersionCode = VersionCodeTest then
begin
LoadHistory ( Strm^ ) ;
LoadPalette ( Strm^ ) ;
DesktopReadViews ( Strm^ ) ;
end
else
begin
Strm^.Seek ( 0 ) ;
Strm^.Truncate ;
Strm^.Reset ;
if Application <> NIL then
MessageBox ( ^C'DESKTOP version change to ' + VersionCode ,
NIL ,
mfWarning + mfOKButton ) ;
end ;
if Strm^.Status <> stOk then
MessageBox ( ^C'Error reading desktop file'#13
+ FileName ,
NIL ,
mfError + mfOkButton ) ;
Dispose ( Strm , Done ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
EVENT
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
COMMAND - easy way to pass commands
===================================================================}
procedure CommandAll ( Command : word ) ;
{-------------------------------------------------------------------
Send command
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
Message ( P , evCommand , Command , NIL ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
Desktop^.ForEach ( @Action ) ;
end ;
{===================================================================
CLOSE - all valid windows
===================================================================}
procedure CloseAll ;
begin
CommandAll ( cmClose ) ;
end ;
{===================================================================
SHOW
===================================================================}
procedure ShowAll ;
{-------------------------------------------------------------------
CALL METHOD
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if P = PVIEW ( ClipWindow ) then EXIT ;
P^.Show ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
DeskTop^.Lock ;
Desktop^.ForEach ( @Action ) ;
DeskTop^.Unlock ;
end ;
{===================================================================
HIDE
===================================================================}
procedure HideAll ;
{-------------------------------------------------------------------
Any view
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
P^.Hide ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
DeskTop^.Lock ;
Desktop^.ForEach ( @Action ) ;
DeskTop^.Unlock ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Another way to do the same thing...
while Desktop^.Current <> NIL do
Desktop^.Current^.Hide;
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
end ;
{===================================================================
EVENT
===================================================================}
procedure ForceEvent ( What , Command : word ) ;
var
E : TEvent ;
begin
E.What := What ;
E.Command := Command ;
Application^.PutEvent ( E ) ;
end ;
{===================================================================
ZOOMED WITHIN OWNER?
===================================================================}
function IsZoomed ( P : PView ) : boolean ;
begin
IsZoomed := FALSE ;
if ( P = NIL ) or ( P^.Owner = NIL ) then EXIT ;
if ( P^.Origin.X <> 0 ) or
( P^.Origin.Y <> 0 ) or
( P^.Size.X <> P^.Owner^.Size.X ) or
( P^.Size.Y <> P^.Owner^.Size.Y ) then
EXIT ;
IsZoomed := TRUE ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
UTILITY
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
function Visible ( P : PView ) : boolean ;
begin
Visible := P^.State and sfVisible <> 0 ;
end ;
function Active ( P : PView ) : boolean ;
begin
Active := P^.State and sfActive <> 0 ;
end ;
function Tileable ( P : PView ) : boolean ;
begin
Tileable := P^.Options and ofTileable <> 0 ;
end ;
function Selectable ( P : PView ) : boolean ;
begin
Selectable := P^.Options and ofSelectable <> 0 ;
end ;
{===================================================================
CAN ZOOM?
===================================================================}
function Zoomable ( P : PView ) : boolean ;
begin
if Selectable ( P ) then
Zoomable := PWINDOW ( P )^.Flags and wfZoom <> 0
else
ZoomAble := FALSE ;
end ;
{===================================================================
ACTIVE - Active and Visible
===================================================================}
function ExistActive : boolean ;
{-------------------------------------------------------------------
Test view
-------------------------------------------------------------------}
function Test ( P : PView ) : boolean ; FAR ;
begin
Test := Active ( P ) and Visible ( P ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
ExistActive := Desktop^.FirstThat ( @Test ) <> NIL ;
end ;
{===================================================================
SELECT - COUNT
===================================================================}
function CountSelectable : byte ;
var
B : byte ;
{-------------------------------------------------------------------
Selectable and Visible
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if Selectable ( P ) and Visible ( P ) then
inc ( B ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
B := 0 ;
Desktop^.ForEach ( @Action ) ;
CountSelectable := B ;
end ;
{===================================================================
TILE - COUNT
===================================================================}
function CountTileable : byte ;
var
B : byte ;
{-------------------------------------------------------------------
Tileable and Visible
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if Tileable ( P ) and Visible ( P ) then
inc ( B ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
B := 0 ;
Desktop^.ForEach ( @Action ) ;
CountTileable := B ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
PICK LIST
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
Get list of titled windows from Desktop
===================================================================}
procedure GetTitleList ( AList : PCollection ) ;
{-------------------------------------------------------------------
-------------------------------------------------------------------}
procedure Action ( P : PView ) ; FAR ;
begin
if not Selectable ( P ) then EXIT ;
with PWINDOW ( P ) ^ do
if GetTitle ( 255 ) <> '' then
AList^.Insert ( NewStr ( GetTitle ( 255 ) ) )
else
AList^.Insert ( NewStr ( '(blank title)' ) ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
Desktop^.ForEach ( @Action ) ;
end ;
{===================================================================
SELECT - get window by its order number
===================================================================}
procedure SelectNum ( AFocus : integer ) ;
var
i : integer ;
{-------------------------------------------------------------------
-------------------------------------------------------------------}
function Test ( P : PView ) : boolean ; FAR ;
begin
Test := FALSE ;
if not Selectable ( P ) then EXIT ;
inc ( i ) ;
if i - 1 <> AFocus then EXIT ;
P^.Show ;
P^.Select ;
Test := TRUE ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PROCESS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
i := 0 ;
Desktop^.FirstThat ( @Test ) ;
end ;